home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.004 / xemacs-1 / xemacs-19.13 / lisp / vm / vm-mark.el < prev    next >
Encoding:
Text File  |  1995-07-28  |  10.6 KB  |  310 lines
  1. ;;; Commands for handling messages marks
  2. ;;; Copyright (C) 1990, 1993, 1994 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-mark)
  19.  
  20. (defun vm-clear-all-marks ()
  21.   "Removes all message marks in the current folder."
  22.   (interactive)
  23.   (vm-select-folder-buffer)
  24.   (vm-check-for-killed-summary)
  25.   (vm-error-if-folder-empty)
  26.   (let ((mp vm-message-list))
  27.     (while mp
  28.       (if (vm-mark-of (car mp))
  29.       (progn
  30.         (vm-set-mark-of (car mp) nil)
  31.         (vm-mark-for-summary-update (car mp) t)))
  32.       (setq mp (cdr mp))))
  33.   (vm-display nil nil '(vm-clear-all-marks)
  34.           '(vm-clear-all-marks marking-message))
  35.   (vm-update-summary-and-mode-line))
  36.  
  37. (defun vm-mark-all-messages ()
  38.   "Mark all messages in the current folder."
  39.   (interactive)
  40.   (vm-select-folder-buffer)
  41.   (vm-check-for-killed-summary)
  42.   (vm-error-if-folder-empty)
  43.   (let ((mp vm-message-list))
  44.     (while mp
  45.       (vm-set-mark-of (car mp) t)
  46.       (vm-mark-for-summary-update (car mp) t)
  47.       (setq mp (cdr mp))))
  48.   (vm-display nil nil '(vm-mark-all-messages)
  49.           '(vm-mark-all-messages marking-message))
  50.   (vm-update-summary-and-mode-line))
  51.  
  52. (defun vm-mark-message (count)
  53.   "Mark the current message.
  54. Numeric prefix argument N means mark the current message and the next
  55. N-1 messages.  A negative N means mark the current message and the
  56. previous N-1 messages."
  57.   (interactive "p")
  58.   (if (interactive-p)
  59.       (vm-follow-summary-cursor))
  60.   (vm-select-folder-buffer)
  61.   (vm-check-for-killed-summary)
  62.   (vm-error-if-folder-empty)
  63.   (let ((direction (if (< count 0) 'backward 'forward))
  64.     (count (vm-abs count))
  65.     (oldmp vm-message-pointer)
  66.     (vm-message-pointer vm-message-pointer))
  67.     (while (not (zerop count))
  68.       (if (not (vm-mark-of (car vm-message-pointer)))
  69.       (progn
  70.         (vm-set-mark-of (car vm-message-pointer) t)
  71.         (vm-mark-for-summary-update (car vm-message-pointer) t)))
  72.       (vm-decrement count)
  73.       (if (not (zerop count))
  74.       (vm-move-message-pointer direction))))
  75.   (vm-display nil nil '(vm-mark-message)
  76.           '(vm-mark-message marking-message))
  77.   (vm-update-summary-and-mode-line))
  78.  
  79. (defun vm-unmark-message (count)
  80.   "Remove the mark from the current message.
  81. Numeric prefix argument N means unmark the current message and the next
  82. N-1 messages.  A negative N means unmark the current message and the
  83. previous N-1 messages."
  84.   (interactive "p")
  85.   (if (interactive-p)
  86.       (vm-follow-summary-cursor))
  87.   (vm-select-folder-buffer)
  88.   (vm-check-for-killed-summary)
  89.   (vm-error-if-folder-empty)
  90.   (let ((mlist (vm-select-marked-or-prefixed-messages count)))
  91.     (while mlist
  92.       (if (vm-mark-of (car mlist))
  93.       (progn
  94.         (vm-set-mark-of (car mlist) nil)
  95.         (vm-mark-for-summary-update (car mlist) t)))
  96.       (setq mlist (cdr mlist))))
  97.   (vm-display nil nil '(vm-unmark-message)
  98.           '(vm-unmark-message marking-message))
  99.   (vm-update-summary-and-mode-line))
  100.  
  101. (defun vm-mark-or-unmark-messages-with-selector (val selector arg)
  102.   (let ((mlist vm-message-list)
  103.     (virtual (eq major-mode 'vm-virtual-mode))
  104.     (arglist (if arg (list arg) nil))
  105.     (count 0))
  106.     (setq selector (intern (concat "vm-vs-" (symbol-name selector))))
  107.     (while mlist
  108.       (if (if virtual
  109.           (save-excursion
  110.         (set-buffer
  111.          (vm-buffer-of
  112.           (vm-real-message-of
  113.            (car mlist))))
  114.         (apply selector (vm-real-message-of (car mlist)) arglist))
  115.         (apply selector (car mlist) arglist))
  116.       (progn
  117.         (vm-set-mark-of (car mlist) val)
  118.         (vm-mark-for-summary-update (car mlist) t)
  119.         (vm-increment count)))
  120.       (setq mlist (cdr mlist)))
  121.     (vm-display nil nil
  122.         '(vm-mark-matching-messages vm-unmark-matching-messages)
  123.         (list this-command 'marking-message))
  124.     (vm-update-summary-and-mode-line)
  125.     (message "%d message%s %smarked"
  126.          count
  127.          (if (= 1 count) "" "s")
  128.          (if val "" "un"))))
  129.  
  130. (defun vm-mark-matching-messages (selector &optional arg)
  131.   "Mark messages matching some criterion.
  132. You can use any of the virtual folder selectors, except for the
  133. `and', `or' and `not' selectors.  See the documentation for the
  134. variable vm-virtual-folder-alist for more information."
  135.   (interactive
  136.    (let ((last-command last-command)
  137.      (this-command this-command))
  138.      (vm-select-folder-buffer)
  139.      (vm-read-virtual-selector "Mark messages: ")))
  140.   (vm-select-folder-buffer)
  141.   (vm-check-for-killed-summary)
  142.   (vm-error-if-folder-empty)
  143.   (vm-mark-or-unmark-messages-with-selector t selector arg))
  144.  
  145. (defun vm-unmark-matching-messages (selector &optional arg)
  146.   "Unmark messages matching some criterion.
  147. You can use any of the virtual folder selectors, except for the
  148. `and', `or' and `not' selectors.  See the documentation for the
  149. variable vm-virtual-folder-alist for more information."
  150.   (interactive
  151.    (let ((last-command last-command)
  152.      (this-command this-command))
  153.      (vm-select-folder-buffer)
  154.      (vm-read-virtual-selector "Unmark messages: ")))
  155.   (vm-select-folder-buffer)
  156.   (vm-check-for-killed-summary)
  157.   (vm-error-if-folder-empty)
  158.   (vm-mark-or-unmark-messages-with-selector nil selector arg))
  159.  
  160. (defun vm-mark-thread-subtree ()
  161.   "Mark all messages in the thread tree rooted at the current message."
  162.   (interactive)
  163.   (vm-follow-summary-cursor)
  164.   (vm-select-folder-buffer)
  165.   (vm-check-for-killed-summary)
  166.   (vm-error-if-folder-empty)
  167.   (vm-mark-or-unmark-thread-subtree t))
  168.  
  169. (defun vm-unmark-thread-subtree ()
  170.   "Unmark all messages in the thread tree rooted at the current message."
  171.   (interactive)
  172.   (vm-follow-summary-cursor)
  173.   (vm-select-folder-buffer)
  174.   (vm-check-for-killed-summary)
  175.   (vm-error-if-folder-empty)
  176.   (vm-mark-or-unmark-thread-subtree nil))
  177.  
  178. (defun vm-mark-or-unmark-thread-subtree (mark)
  179.   (vm-build-threads-if-unbuilt)
  180.   (let ((list (list (car vm-message-pointer)))
  181.     (loop-obarray (make-vector 29 0))
  182.     subject-sym id-sym)
  183.     (while list
  184.       (if (not (eq (vm-mark-of (car list)) mark))
  185.       (progn
  186.         (vm-set-mark-of (car list) mark)
  187.         (vm-mark-for-summary-update (car list))))
  188.       (setq id-sym (car (vm-last (vm-th-thread-list (car list)))))
  189.       (if (null (intern-soft (symbol-name id-sym) loop-obarray))
  190.       (progn
  191.         (intern (symbol-name id-sym) loop-obarray)
  192.         (nconc list (copy-sequence (get id-sym 'children)))
  193.         (setq subject-sym (intern (vm-so-sortable-subject (car list))
  194.                       vm-thread-subject-obarray))
  195.         (if (and (boundp subject-sym) 
  196.              (eq id-sym (aref (symbol-value subject-sym) 0)))
  197.         (nconc list (copy-sequence
  198.                  (aref (symbol-value subject-sym) 2))))))
  199.       (setq list (cdr list))))
  200.   (vm-display nil nil
  201.           '(vm-mark-thread-subtree vm-unmark-thread-subtree)
  202.           (list this-command 'marking-message))
  203.   (vm-update-summary-and-mode-line))
  204.  
  205. (defun vm-mark-messages-same-subject ()
  206.   "Mark all messages with the same subject as the current message."
  207.   (interactive)
  208.   (vm-follow-summary-cursor)
  209.   (vm-select-folder-buffer)
  210.   (vm-check-for-killed-summary)
  211.   (vm-error-if-folder-empty)
  212.   (vm-mark-or-unmark-messages-same-subject t))
  213.  
  214. (defun vm-unmark-messages-same-subject ()
  215.   "Unmark all messages with the same subject as the current message."
  216.   (interactive)
  217.   (vm-follow-summary-cursor)
  218.   (vm-select-folder-buffer)
  219.   (vm-check-for-killed-summary)
  220.   (vm-error-if-folder-empty)
  221.   (vm-mark-or-unmark-messages-same-subject nil))
  222.  
  223. (defun vm-mark-or-unmark-messages-same-subject (mark)
  224.   (let ((mp vm-message-list)
  225.     (mark-count 0)
  226.     (subject (vm-so-sortable-subject (car vm-message-pointer))))
  227.     (while mp
  228.       (if (and (not (eq (vm-mark-of (car mp)) mark))
  229.            (string-equal subject (vm-so-sortable-subject (car mp))))
  230.       (progn
  231.         (vm-set-mark-of (car mp) mark)
  232.         (vm-increment mark-count)
  233.         (vm-mark-for-summary-update (car mp) t)))
  234.       (setq mp (cdr mp)))
  235.     (if (zerop mark-count)
  236.     (message "No messages %smarked" (if mark "" "un"))
  237.       (message "%d message%s %smarked"
  238.            mark-count
  239.            (if (= 1 mark-count) "" "s")
  240.            (if mark "" "un"))))
  241.   (vm-display nil nil
  242.           '(vm-mark-messages-same-subject
  243.         vm-unmark-messages-same-subject)
  244.           (list this-command 'marking-message))
  245.   (vm-update-summary-and-mode-line))
  246.  
  247. (defun vm-mark-messages-same-author ()
  248.   "Mark all messages with the same author as the current message."
  249.   (interactive)
  250.   (vm-follow-summary-cursor)
  251.   (vm-select-folder-buffer)
  252.   (vm-check-for-killed-summary)
  253.   (vm-error-if-folder-empty)
  254.   (vm-mark-or-unmark-messages-same-author t))
  255.  
  256. (defun vm-unmark-messages-same-author ()
  257.   "Unmark all messages with the same author as the current message."
  258.   (interactive)
  259.   (vm-follow-summary-cursor)
  260.   (vm-select-folder-buffer)
  261.   (vm-check-for-killed-summary)
  262.   (vm-error-if-folder-empty)
  263.   (vm-mark-or-unmark-messages-same-author nil))
  264.  
  265. (defun vm-mark-or-unmark-messages-same-author (mark)
  266.   (let ((mp vm-message-list)
  267.     (mark-count 0)
  268.     (author (vm-su-from (car vm-message-pointer))))
  269.     (while mp
  270.       (if (and (not (eq (vm-mark-of (car mp)) mark))
  271.            (string-equal author (vm-su-from (car mp))))
  272.       (progn
  273.         (vm-set-mark-of (car mp) mark)
  274.         (vm-increment mark-count)
  275.         (vm-mark-for-summary-update (car mp) t)))
  276.       (setq mp (cdr mp)))
  277.     (if (zerop mark-count)
  278.     (message "No messages %smarked" (if mark "" "un"))
  279.       (message "%d message%s %smarked"
  280.            mark-count
  281.            (if (= 1 mark-count) "" "s")
  282.            (if mark "" "un"))))
  283.   (vm-display nil nil
  284.           '(vm-mark-messages-same-author
  285.         vm-unmark-messages-same-author)
  286.           (list this-command 'marking-message))
  287.   (vm-update-summary-and-mode-line))
  288.  
  289. (defun vm-next-command-uses-marks ()
  290.   "Does nothing except insure that the next VM command will operate only
  291. on the marked messages in the current folder."
  292.   (interactive)
  293.   (setq this-command 'vm-next-command-uses-marks)
  294.   (vm-unsaved-message "Next command uses marks...")
  295.   (vm-display nil nil '(vm-next-command-uses-marks)
  296.           '(vm-next-command-uses-marks)))
  297.  
  298. (defun vm-marked-messages ()
  299.   (let (list (mp vm-message-list))
  300.     (while mp
  301.       (if (vm-mark-of (car mp))
  302.       (setq list (cons (car mp) list)))
  303.       (setq mp (cdr mp)))
  304.     (nreverse list)))
  305.  
  306. (defun vm-mark-help ()
  307.   (interactive)
  308.   (vm-display nil nil '(vm-mark-help) '(vm-mark-help))
  309.   (message "MM = mark, MU = unmark, Mm = mark all, Mu = unmark all, MN = use marks, ..."))
  310.